;;; Those flashing buttons used by ZMail -*- Mode:LISP; Package:TV; Base:8 -*-
;;; This is SYS: ZMAIL; BUTTON
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **

;;; Some frame and pane help
(DEFUN (WHITE-INCLUDE-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC IGNORE)
  `(INTERDIGITATED-WHITESPACE :WHITE :INCLUDE
    . ,(CDDR OLD-DESC)))

(DEFUN (PANES-IN-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC IGNORE &AUX SIZE PANES)
  (SETF `(NAME PANES-IN-WHITESPACE ,SIZE ,PANES) OLD-DESC)
  `(WHITE-INCLUDE-WHITESPACE
    ,SIZE (:EVEN)
    ,PANES
    ,(LOOP FOR PANE IN PANES COLLECT `(,PANE :ASK :PANE-SIZE))))

(DEFUN (SINGLE-PANE-IN-WHITESPACE CONSTRAINT-MACRO) (OLD-DESC IGNORE &AUX PANE)
  (SETF `(NAME SINGLE-PANE-IN-WHITESPACE ,PANE) OLD-DESC)
  `(PANES-IN-WHITESPACE (:ASK-WINDOW ,PANE :PANE-SIZE) (,PANE)))

(DEFUN (FLOATING-BUTTONS CONSTRAINT-MACRO) (OLD-DESC STACKING &AUX PANES CONVERSE-STACKING
                                                                   NAME-1 NAME-2)
  (SETF `(NAME FLOATING-PANES ,PANES) OLD-DESC)
  (SETQ CONVERSE-STACKING (IF (EQ STACKING :VERTICAL) :HORIZONTAL :VERTICAL)
        NAME-1 (GENSYM) NAME-2 (GENSYM))
  `(,CONVERSE-STACKING (:ASK-WINDOW ,(CAR PANES) :PANE-SIZE-WITH-WHITESPACE)
    (,NAME-1)
    ((,NAME-1 ,STACKING (:EVEN)
      (,NAME-2)
      ((,NAME-2 PANES-IN-WHITESPACE (:ASK-WINDOW ,(CAR PANES) :PANE-SIZE)
        ,PANES))))))

(DEFUN (FLOATING-MENUS CONSTRAINT-MACRO) (OLD-DESC IGNORE &AUX SIZE PANES NAMES)
  (SETF `(NAME FLOATING-MENUS ,SIZE ,PANES) OLD-DESC)
  (SETQ NAMES (LOOP FOR PANE IN PANES COLLECT (GENSYM)))
  `(WHITE-INCLUDE-WHITESPACE ,SIZE (:EVEN)
    ,NAMES
    ,(LOOP FOR PANE IN PANES
           FOR NAME IN NAMES
           COLLECT `(,NAME WHITE-INCLUDE-WHITESPACE
                     (:ASK-WINDOW ,PANE :PANE-SIZE) (:EVEN)
                     (,PANE)
                     ((,PANE :ASK :PANE-SIZE))))))

(DEFFLAVOR WHITESPACE-PANE-MIXIN () ())

(DEFMETHOD (WHITESPACE-PANE-MIXIN :PANE-SIZE-WITH-WHITESPACE)
           (REM-WIDTH REM-HEIGHT MAX-WIDTH MAX-HEIGHT STACKING &AUX WITHOUT)
  (SETQ WITHOUT (SEND SELF :PANE-SIZE REM-WIDTH REM-HEIGHT MAX-WIDTH MAX-HEIGHT STACKING))
  (SETQ WITHOUT (+ WITHOUT 5))
  (CASE STACKING
    (:VERTICAL (MIN REM-HEIGHT WITHOUT))
    (:HORIZONTAL (MIN REM-WIDTH WITHOUT))))

(DEFFLAVOR XOR-ACCENT-MIXIN ((ACCENT NIL)) ()
  (:GETTABLE-INSTANCE-VARIABLES ACCENT)
  (:REQUIRED-FLAVORS ESSENTIAL-WINDOW))

(DEFMETHOD (XOR-ACCENT-MIXIN :SET-ACCENT) (ACCENT-P)
  (OR (EQ (NOT ACCENT-P) (NOT ACCENT))
      (SHEET-FORCE-ACCESS (SELF)
        (SEND SELF :XOR-ACCENT)))
  (SETQ ACCENT ACCENT-P))

(DEFMETHOD (XOR-ACCENT-MIXIN :AFTER :REFRESH) (&OPTIONAL IGNORE)
  (OR RESTORED-BITS-P (NOT ACCENT)
      (SEND SELF :XOR-ACCENT)))

(DEFMETHOD (XOR-ACCENT-MIXIN :XOR-ACCENT) ()
  (PREPARE-SHEET (SELF)
    (%DRAW-RECTANGLE (SHEET-INSIDE-WIDTH) (SHEET-INSIDE-HEIGHT)
                     (SHEET-INSIDE-LEFT) (SHEET-INSIDE-TOP) ALU-XOR SELF)))

(DEFFLAVOR BASIC-BUTTON ((DOCUMENTATION NIL)) ()
  (:REQUIRED-FLAVORS ESSENTIAL-WINDOW)
  (:INITABLE-INSTANCE-VARIABLES DOCUMENTATION))

(DEFMETHOD (BASIC-BUTTON :AFTER :REFRESH) (&REST IGNORE)
  (OR RESTORED-BITS-P (SHEET-DISPLAY-X-Y-CENTERED-STRING SELF NAME)))

(DEFMETHOD (BASIC-BUTTON :SET-NAME) (NEW-NAME)
  (SETQ NAME NEW-NAME)
  (SHEET-FORCE-ACCESS (SELF)
    (SEND SELF :REFRESH)))

(DEFMETHOD (BASIC-BUTTON :WHO-LINE-DOCUMENTATION-STRING) ()
  DOCUMENTATION)

(DEFMETHOD (BASIC-BUTTON :PANE-SIZE) (REM-WIDTH REM-HEIGHT IGNORE IGNORE STACKING)
  (CASE STACKING
    (:VERTICAL (MIN REM-HEIGHT HEIGHT))
    (:HORIZONTAL (MIN REM-WIDTH
                      (LET ((INSIDE-WIDTH (+ (* CHAR-WIDTH 2)   ;Allow a little whitespace
                                             (SHEET-STRING-LENGTH SELF NAME))))
                        (LET ((L (GET-HANDLER-FOR SELF :LABEL-SIZE)))
                          (AND L (SETQ L (SEND L :LABEL-SIZE))
                               (SETQ INSIDE-WIDTH (MAX INSIDE-WIDTH L))))
                        (+ INSIDE-WIDTH LEFT-MARGIN-SIZE RIGHT-MARGIN-SIZE))))))

(DEFFLAVOR SMALL-BUTTON-PANE () (XOR-ACCENT-MIXIN BASIC-BUTTON LIST-MOUSE-BUTTONS-MIXIN
                                 WHITESPACE-PANE-MIXIN WINDOW-WITHOUT-LABEL)
  (:DEFAULT-INIT-PLIST :CHARACTER-HEIGHT 1 :BLINKER-P NIL :MORE-P NIL))

(DEFMETHOD (SMALL-BUTTON-PANE :BEFORE :FORCE-KBD-INPUT) (IGNORE)
  (SEND SELF :SET-ACCENT T))

(DEFMETHOD (SMALL-BUTTON-PANE :MOUSE-SELECT) (&REST IGNORE)
  )

(DEFFLAVOR MEDIUM-BUTTON-PANE () (SMALL-BUTTON-PANE)
  (:DEFAULT-INIT-PLIST :FONT-MAP '(FONTS:MEDFNT)))

(DEFFLAVOR BUTTON-PANE () (SMALL-BUTTON-PANE)
  (:DEFAULT-INIT-PLIST :FONT-MAP '(FONTS:HL12B) :BORDERS 2))

(DEFFLAVOR BIG-BUTTON-PANE () (SMALL-BUTTON-PANE)
  (:DEFAULT-INIT-PLIST :BORDERS 3 :FONT-MAP '(FONTS:BIGFNT)))

(DEFFLAVOR BIG-BUTTON-WITH-TOP-OUTSIDE-LABEL-PANE () (TOP-LABEL-MIXIN BUTTON-PANE))

;Define a :SET-PANES-ITEM-LIST message that changes one of our panes'
;ITEM-LIST while taking account of the fact that this may cause the pane
;(a menu, presumably) to change its size.
(DEFFLAVOR ITEM-LIST-PANE-KLUDGE () ()
  (:REQUIRED-FLAVORS BASIC-FRAME))

(DEFMETHOD (ITEM-LIST-PANE-KLUDGE :SET-PANES-ITEM-LIST) (PANE NEW-ITEM-LIST)
  (SETQ PANE (SEND SELF :GET-PANE PANE))
  (COND ((NOT (EQUAL NEW-ITEM-LIST (SEND PANE :ITEM-LIST)))
         (WITHOUT-SCREEN-MANAGEMENT
           (LET-GLOBALLY ((RECURSION T))
             (SEND PANE :DEEXPOSE)))            ;This is necessary because it may not fit
         (SEND PANE :SET-ITEM-LIST NEW-ITEM-LIST)
         T)))

(DEFFLAVOR FRAME-WITH-XOR-BUTTONS () ()
  (:REQUIRED-FLAVORS BASIC-CONSTRAINT-FRAME))

(DEFMETHOD (FRAME-WITH-XOR-BUTTONS :TURN-OFF-ACCENTS) ()
  (DO ((-PANES- INTERNAL-PANES (CDR -PANES-))
       (PANE))
      ((NULL -PANES-))
    (SETQ PANE (CDAR -PANES-))
    (SEND PANE :SEND-IF-HANDLES :SET-ACCENT NIL)))

(DEFMETHOD (FRAME-WITH-XOR-BUTTONS :SET-PANES-NAME) (PANE NEW-NAME &AUX X Y)
  (SETQ PANE (SEND SELF :GET-PANE PANE))
  (COND ((NOT (EQUAL NEW-NAME (SEND PANE :NAME)))
         (SETQ X (+ (SHEET-X-OFFSET PANE) (TRUNCATE (SHEET-WIDTH PANE) 2))
               Y (SHEET-Y-OFFSET PANE))
         (DELAYING-SCREEN-MANAGEMENT
           (LET-GLOBALLY ((RECURSION T))
             (SEND PANE :DEEXPOSE)
             (SEND PANE :SET-NAME NEW-NAME)
             (LET ((NEW-WIDTH (SEND PANE :PANE-SIZE (SHEET-INSIDE-WIDTH)
                                    (SHEET-INSIDE-HEIGHT) (SHEET-INSIDE-WIDTH)
                                    (SHEET-INSIDE-HEIGHT) :HORIZONTAL)))
               (DECF X (TRUNCATE NEW-WIDTH 2))
               (SEND PANE :SET-EDGES X Y (+ X NEW-WIDTH) (+ Y (SHEET-HEIGHT PANE))))
             ;; Otherwise Clear-screen loses afterward if button has become bigger.
             ;; Does this slow things down too much?
             (SEND SELF :SET-CONFIGURATION CONFIGURATION)
;            (SEND PANE :EXPOSE)
             )))))

(DEFFLAVOR BUTTONS-FRAME
        ()
        (FRAME-WITH-XOR-BUTTONS CONSTRAINT-FRAME-WITH-SHARED-IO-BUFFER BORDERS-MIXIN))

(DEFMETHOD (BUTTONS-FRAME :BEFORE :INIT) (IGNORE &AUX PANES-NAMES)
  (SETQ PANES-NAMES (MAPCAR #'CAR PANES))
  (SETQ CONSTRAINTS `((ONLY . ((BUTTONS)
                               ((BUTTONS :HORIZONTAL (1.0) (BUTTONS-1)
                                 ((BUTTONS-1 WHITE-INCLUDE-WHITESPACE (1.0) (:EVEN)
                                             (BUTTONS-2)
                                   ((BUTTONS-2 FLOATING-BUTTONS ,PANES-NAMES)))))))))))

(DEFMETHOD (BUTTONS-FRAME :PANE-SIZE) (&REST ARGS)
  (+ (LEXPR-SEND (CDAR INTERNAL-PANES) :PANE-SIZE ARGS) 5))

(DEFMETHOD (BUTTONS-FRAME :CHANGE-BUTTONS) (&REST PANES-AND-NAMES)
  (LOOP FOR (PANE PANE-NAME) ON PANES-AND-NAMES BY 'CDDR
        DO (SETF (SHEET-NAME PANE) PANE-NAME)
        FINALLY (SEND SELF :SET-CONFIGURATION 'ONLY)))

(COMPILE-FLAVOR-METHODS BIG-BUTTON-PANE BIG-BUTTON-WITH-TOP-OUTSIDE-LABEL-PANE BUTTON-PANE
                        MEDIUM-BUTTON-PANE SMALL-BUTTON-PANE BUTTONS-FRAME)
